Delphi Programmer's Power Pack/Delphi Volume 1.iso/e_to_l/fbuilder/delphi/demos/dbfuncs.pas

Pascal/Delphi Source File | 1996-09-15 | 12.4 KB | 472 lines

{*                                *}
{*  FormulaBuilder 1.0            *}
{*  YGB Software, Inc.            *}
{*  Copyright 1995 Clayton Collie *}
{*  All Rights Reserved           *}
Unit DBFuncs;
Interface
Uses Sysutils,DB,DBTables,FBDBCOMP;

{* This Demonstration unit implements the functions

   DBSUM( Expression <,Criteria > )
   DBAVG( Expression <,Criteria > )
   DBMAX( Expression <,Criteria > )
   DBMIN( Expression <,Criteria > )
   DBCOUNT(< Criteria >)

  These functions work only if called from a TDSExpression or descendant.
  To use these functions, simply include this unit in the USES statement
  of any unit in your project.

  These functions duplicate functionality existing within the BDE,
  but they are useful in demonstrating useful techniques for using
  FormulaBuilder.

*}


IMPLEMENTATION
uses  FBCALC;

Var fnIdDBSUM,fnIdDBAVG, fnIdDBMAX, fnIdDBMIN, fnidDBCOUNT : integer;


Procedure PrepareDataset( dataset : TDataset; var bookmark : TBookmark );
begin
  {* Disable any components that reference the dataset.  Don't
     want those updating while we traverse the table. *}
   dataset.DisableControls;
   BookMark := dataset.GetBookMark;
end;


Procedure RestoreDataset( dataset : TDataset; var bookmark : TBookmark );
begin
   With dataset do
   begin
     GotoBookmark(BookMark);
     FreeBookmark(BookMark);
     EnableControls;
   end;
end;




{
Common Routines for the DBXXX functions
}
CONST
      INF      = 1.1E+4932;  {Extended}
      NEGINF   = 3.4E-4932;  {Extended}


Function DBGetParams(ExprData           : longint;
                     var   DBDataset    : TDataset;
                     const ExprString,
                           FilterString : String;
                     var   ExprIterator,
                           ExprFilter   : TDSExpression) : Integer;
var ntype : byte;
begin
  Result := EXPR_SUCCESS;
  TRY
     { NOTE! - this ONLY WORKS IF this proc IS CALLED FROM A
       TCustomDSEXPRESSION or descendant !}
     DBDataset := TDSExpression(ExprData).DataSet;
   EXCEPT
     Result := EXPR_INVALID_DATASET;  { Invalid_Expression }
     exit;
   END;
   exprFilter := NIL;
   exprIterator := TDSExpression.Create(NIL);
   TRY
     with ExprIterator do
     begin
       UseExceptions := False;
       Dataset       := DBDataSet;
       Formula       := ExprString;
       Result        := Status;
       if Result <> EXPR_SUCCESS then
       begin
         Free;
         Exit;
       end;
       ntype := ReturnType;
       if not (ntype in [vtINTEGER,vtFLOAT]) then
       begin
         result := EXPR_TYPE_MISMATCH;
         free;
         exit;
       end;
     end;
     if FilterString = '' then exit;
     exprFilter := TDSExpression.Create(NIL);
     with exprFilter do
     begin
         UseExceptions := False;
         Dataset       := DBDataset;
         Formula       := FilterString;
         Result        := Status;
         if Result <> EXPR_SUCCESS then
         begin
           exprIterator.Free;
           Free;
           Exit;
         end;
         if not (ReturnType = vtBOOLEAN) then
         begin
           Result := EXPR_TYPE_MISMATCH;    { EXPR_INVALID_FILTER }
           exprIterator.Free;
           free;
           exit;
         end;
       end; { With ExprFilter }
   EXCEPT
     ExprIterator.Free;
     exprFilter.Free;
   END;
end;

{********}

{ DBSum(Formula<,Criteria >) }

Procedure DBSUM( nParamcount    : byte;
                const params   : TActParamList;
                var ReturnVal  : TVALUEREC;
                var nErrCode   : Integer;
                ExprData       : longint); export;
var
  fDBSUMResult : double;
  exprCriteria : TDSExpression;
  exprDBSUM    : TDSExpression;
  tblDBSUM     : TDataset;
  BookMark     : TBookMark;
  ntype        : byte;
  sfilter      : string;

begin
  if nParamCount = 2 then
     sFilter := params[1].vpString^
   else
     sFilter := '';
  nErrCode := DBGetParams(ExprData,tblDBSUM,params[0].vpString^,sFilter,
                          ExprDBSUM,exprCriteria);

  if nErrCode <> EXPR_SUCCESS then exit;
  TRY
    ntype        := ExprDBSum.ReturnType;
    fDBSUMResult := 0;
    PrepareDataset(tblDBSUM,BookMark);
    TRY
       tblDBSUM.First;
       while not tblDBSUM.EOF do
       begin
          if (nParamCount = 1) or exprCriteria.AsBoolean then
          Case ntype of
              vtINTEGER : fDBSUMResult := fDBSUMResult + exprDBSUM.AsInteger;
              vtFLOAT   : fDBSUMResult := fDBSUMResult + exprDBSUM.AsFloat;
          end;
          tblDBSUM.Next;
        end;
        ReturnVal.vFloat := fDBSUMResult;
    FINALLY
       RestoreDataset(tblDBSUM,BookMark);
    END;
    nErrcode := EXPR_SUCCESS;  { not really necessary, since this is its value on entry }
   FINALLY
     ExprDBSUM.Free;
     exprCriteria.Free;
   END;
end;



{ DBAVG(Formula<,Criteria >) }

Procedure DBAVG( nParamcount    : byte;
                const params   : TActParamList;
                var ReturnVal  : TVALUEREC;
                var nErrCode   : Integer;
                ExprData       : longint); export;
var
  fDBAVGResult : double;
  exprCriteria : TDSExpression;
  exprDBAVG    : TDSExpression;
  tblDBAVG     : TDataset;
  lCount       : longint;
  BookMark     : TBookMark;
  ntype        : byte;
  sfilter      : string;

begin
  if nParamCount = 2 then
     sFilter := params[1].vpString^
   else
     sFilter := '';
  nErrCode := DBGetParams(ExprData,tblDBAVG,params[0].vpString^,sFilter,
                          ExprDBAVG,exprCriteria);

  if nErrCode <> EXPR_SUCCESS then exit;
  TRY
    ntype := ExprDBAVG.ReturnType;
    fDBAVGResult := 0;
    PrepareDataset(tblDBAVG,BookMark);
    lCount := 0;
    TRY
       tblDBAVG.First;
       while not tblDBAVG.EOF do
       begin
         if (nParamCount = 1) or exprCriteria.AsBoolean then
         begin
           Case ntype of
              vtINTEGER : fDBAVGResult := fDBAVGResult + exprDBAVG.AsInteger;
              vtFLOAT   : fDBAVGResult := fDBAVGResult + exprDBAVG.AsFloat;
           end;
           inc(lCount);
          end;
          tblDBAVG.Next;
        end;
        if lCount = 0 then
           fDBAVGResult := 0
         else
           fDBAVGResult := (fDBAvgResult / lCount);
         ReturnVal.vFloat := fDBAVGResult;
     FINALLY
       RestoreDataset(tblDBAVG,BookMark);
     END;
     nErrcode := EXPR_SUCCESS;  { not really necessary, since this is its value on entry }
   FINALLY
     ExprDBAVG.Free;
     exprCriteria.Free;
   END;
end;



{ DBCOUNT(< Criteria >) }

Procedure DBCOUNT( nParamcount    : byte;
                   const params   : TActParamList;
                   var ReturnVal  : TVALUEREC;
                   var nErrCode   : Integer;
                   ExprData       : longint); export;
var
  exprFilter   : TDSExpression;
  tblDBCOUNT   : TDataset;
  lCount       : longint;
  BookMark     : TBookMark;
  ntype        : byte;

begin
  TRY
     tblDBCOUNT := TDSExpression(ExprData).DataSet;
   EXCEPT
     nErrCode := EXPR_INVALID_DATASET;  { Invalid_Expression }
     exit;
   END;
  if (nParamcount = 0) or (params[0].vpString^ = '') then
  begin
    ReturnVal.vInteger := tblDBCOUNT.RecordCount;
    exit;
  end;
  exprFilter := TDSExpression.Create(NIL);
  with exprFilter do
  begin
    UseExceptions := False;
    Dataset       := tblDBCOUNT;
    Formula       := params[0].vpString^;
    nErrCode      := Status;
    if nErrCode <> EXPR_SUCCESS then
    begin
      Free;
      Exit;
    end;
    if not (ReturnType = vtBOOLEAN) then
    begin
      nErrCode := EXPR_TYPE_MISMATCH;    { EXPR_INVALID_FILTER }
      free;
      exit;
    end;
  end; {with }
  TRY
    PrepareDataset(tblDBCOUNT,BookMark);
    lCount := 0;
    TRY
      tblDBCOUNT.First;
      while not tblDBCOUNT.EOF do
      begin
        inc(lcount,ord(exprFilter.AsBoolean));
        if exprFilter.Status <> EXPR_SUCCESS then
        begin
          nErrCode := exprFilter.Status;
          RestoreDataset(tblDBCOUNT,BookMark);
          exit;
         end;
         tblDBCOUNT.Next;
       end;
       ReturnVal.vInteger := lCount;
     FINALLY
       RestoreDataset(tblDBCOUNT,BookMark);
     END;
     nErrcode := EXPR_SUCCESS;  { not really necessary, since this is its value on entry }
    FINALLY
      exprFilter.Free;
    END;
end; { DBCOunt }



{ DBMIN(Formula<,Criteria >) }

Procedure DBMIN( nParamcount    : byte;
                 const params   : TActParamList;
                 var ReturnVal  : TVALUEREC;
                 var nErrCode   : Integer;
                 ExprData       : longint); export;
var
  fDBMINResult : extended;
  fTemp        : extended;
  exprCriteria : TDSExpression;
  exprDBMIN    : TDSExpression;
  tblDBMIN     : TDataset;
  BookMark     : TBookMark;
  ntype        : byte;
  sfilter      : string;

begin
  if nParamCount = 2 then
     sFilter := params[2].vpString^
   else
     sFilter := '';
  nErrCode := DBGetParams(ExprData,tblDBMIN,params[0].vpString^,sFilter,
                          ExprDBMIN,exprCriteria);

  if nErrCode <> EXPR_SUCCESS then exit;

  ntype        := exprDBMIN.ReturnType;
  fDBMINResult := INF;
  TRY
    PrepareDataset(tblDBMIN,BookMark);
    TRY
       tblDBMIN.First;
       while not tblDBMIN.EOF do
       begin
         if (nParamCount = 1) or exprCriteria.AsBoolean then
         begin
            Case ntype of
                vtINTEGER : fTemp := exprDBMIN.AsInteger;
                vtFLOAT   : fTemp := exprDBMIN.AsFloat;
            end;
            if fTemp < fDBMINResult then
               fDBMINResult := fTemp;
          end;
          tblDBMIN.Next;
        end;
        ReturnVal.vFloat := fDBMINResult;
      FINALLY
        RestoreDataset(tblDBMIN,BookMark);
      END;
      nErrcode := EXPR_SUCCESS;  { not really necessary, since this is its value on entry }
    FINALLY
      ExprDBMIN.Free;
      exprCriteria.Free;
    END;
end;



{ DBMAX(Formula<,Criteria >) }

Procedure DBMAX( nParamcount    : byte;
                 const params   : TActParamList;
                 var ReturnVal  : TVALUEREC;
                 var nErrCode   : Integer;
                 ExprData       : longint); export;
var
  fDBMAXResult : extended;
  fTemp        : double;
  exprCriteria : TDSExpression;
  exprDBMAX    : TDSExpression;
  tblDBMAX     : TDataset;
  BookMark     : TBookMark;
  ntype        : byte;
  sfilter      : string;

begin
  if nParamCount = 2 then
     sFilter := params[2].vpString^
   else
     sFilter := '';
  nErrCode := DBGetParams(ExprData,tblDBMAX,params[0].vpString^,sFilter,
                          ExprDBMAX,exprCriteria);

  if nErrCode <> EXPR_SUCCESS then exit;

  ntype := ExprDBMAX.ReturnType;
  fDBMAXResult := 0;
  TRY
     PrepareDataset(tblDBMAX,BookMark);
     TRY
       tblDBMAX.First;
       while not tblDBMAX.EOF do
       begin
         if (nParamCount = 1) or exprCriteria.AsBoolean then
         begin
            Case ntype of
                 vtINTEGER : fTemp := exprDBMAX.AsInteger;
                 vtFLOAT   : fTemp := exprDBMAX.AsFloat;
             end;
             if fTemp > fDBMAXResult then
                fDBMAXResult := fTemp;
          end;
          tblDBMAX.Next;
        end;
        ReturnVal.vFloat := fDBMAXResult;
      FINALLY
        RestoreDataset(tblDBMAX,BookMark);
      END;
      nErrcode := EXPR_SUCCESS;  { not really necessary, since this is its value on entry }
   FINALLY
     ExprDBMAX.Free;
     exprCriteria.Free;
   END;
end;




Procedure RegisterFunctions;
begin
  InitFbuilder;
  If not FBLoaded then exit;
  fnIdDBSUM   := FBRegisterFunction('DBSUM',vtFLOAT,'ss',1,DBSUM);
  fnIdDBMIN   := FBRegisterFunction('DBMIN',vtFLOAT,'ss',1,DBMIN);
  fnIdDBMAX   := FBRegisterFunction('DBMAX',vtFLOAT,'ss',1,DBMAX);
  fnIdDBAVG   := FBRegisterFunction('DBAVG',vtFLOAT,'ss',1,DBAVG);
  fnIdDBCOUNT := FBRegisterFunction('DBSUM',vtINTEGER,'s',0,DBCOUNT);
end;


Procedure UnRegisterFunctions; far;
begin
  if not FBLoaded then exit;
  FBUnregisterFunction(fnIdDBSUM);
  FBUnregisterFunction(fnIdDBMAX);
  FBUnregisterFunction(fnIdDBMIN);
  FBUnregisterFunction(fnIdDBAVG);
  FBUnregisterFunction(fnIdDBCOUNT);
  FreeFBuilder;
end;




INITIALIZATION
  RegisterFunctions;
  AddExitProc(UnRegisterFunctions);
END.